home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / t2.c < prev    next >
C/C++ Source or Header  |  1993-07-03  |  11KB  |  469 lines
  1.  
  2.  
  3. /* A table: 
  4.    table_population(t)==int
  5.    table_threshold(t)==int
  6.    table_values(t)=vector
  7.    
  8.    The hashing technique is an implementation of CACM 6/90, Pearson pp677-681
  9.  
  10. */
  11. #include "funcalls.h"
  12. #include "defs.h"
  13. #include "structs.h"
  14. #include "error.h"
  15. #include "global.h"
  16. #include "modboot.h"
  17.  
  18. #include "calls.h"
  19. #include "table.h"
  20. #include "t2.h"
  21.  
  22.  
  23. static void table_rehash(LispObject *, LispObject );
  24.  
  25. /* Hash table --- need 16 bit hash values */
  26.  
  27. unsigned char hash_table[]=
  28. { /* Bunch of numbers from CACM 6/90 -- extra 1 to avoid arith in hash fn */
  29.   1, 87, 49, 12, 176, 178, 102, 166, 121, 193, 6, 84, 249, 230, 44, 163,
  30.   14, 197, 213, 181, 161, 85, 218, 80, 64, 239, 24, 226, 236, 142, 38, 200,
  31.   110, 177, 104, 103, 141, 253, 255, 50, 77, 101, 81, 18, 45, 96, 31, 222,
  32.   25, 107, 190, 70, 86, 237, 240,  34, 72, 242, 20, 214, 244, 227, 149, 235,
  33.   97, 234, 57, 22, 60, 250, 82, 175, 208, 5, 127, 199, 111, 62, 135, 248,
  34.   174, 169, 211, 58, 66, 154, 106, 195, 245, 171, 17, 187, 182, 179, 0, 243,
  35.   132, 56, 148, 75, 128, 133, 158, 100, 130, 126, 91, 13, 153, 246, 216, 219,
  36.   119, 68, 223, 78, 83, 88, 201, 99, 122, 11, 92, 32, 136, 114, 52, 10,
  37.   138, 30, 48, 183, 156, 35, 61, 26, 143, 74, 251, 94, 129, 162, 63, 152,
  38.   170, 7, 115, 167, 241, 206, 3, 150, 55, 59, 151, 220, 90, 53, 23, 131,
  39.   125, 173, 15, 238, 79, 95, 89, 16, 105, 137, 225, 224, 217, 160, 37, 123,
  40.   118, 73, 2, 157, 46, 116, 9, 145, 134, 228, 207, 212, 202, 215, 69, 229,
  41.   27, 188, 67, 124, 168, 252, 42, 4, 29, 108, 21, 247, 19, 205, 39, 203,
  42.   233, 40, 186, 147, 198, 192, 155, 33, 164, 191, 98, 204, 165, 180, 117, 76,
  43.   140, 36, 210, 172, 41, 54, 159, 8, 185, 232, 113, 196, 231, 47, 146, 120,
  44.   51, 65, 28, 144, 254, 221, 93, 189, 194, 139, 112, 43, 71, 109, 184, 209,
  45.   /* repeat to avoid taking mods. */
  46.   1, 87
  47.   };
  48.  
  49. /* Hash should be good enough that last dn bits are a hash value */
  50. int hash(char *ptr)
  51. {
  52.   unsigned char h1=0,h2=0,h3=0;
  53.  
  54.   while (*ptr!='\0')
  55.     { 
  56.       h1 = hash_table[h1 ^ (*ptr)];
  57.       h2 = hash_table[h2 ^ (*ptr+1)];
  58.       h3 = hash_table[h3 ^ (*ptr+2)];
  59.       ptr++;
  60.     }
  61.   return (((int) h1<<16) | ((int)h2<<8) | (int) h3);
  62. }
  63.  
  64. #define total_hash(x)     (is_symbol(x) ? ((x)->SYMBOL.hash) \
  65.              : is_c_function(x) ? ((x)->C_FUNCTION.name->SYMBOL.hash) \
  66.              : general_hash(stacktop,x))
  67. #define total_rehash(ohash) (is_symbol(x) ? (rehash_string(x)) : hash((char *) &ohash));
  68.  
  69. #define TBUG(x) 
  70.  
  71. EUFUN_1( Fn_tablep, x)
  72. {
  73.   if (is_table(x)) 
  74.     return lisptrue;
  75.   
  76.   return nil;
  77. }
  78. EUFUN_CLOSE
  79.  
  80. EUFUN_1(Fn_symbol_hash, sym)
  81. {
  82.   return allocate_integer(stacktop,sym->SYMBOL.hash);
  83. }
  84. EUFUN_CLOSE
  85.  
  86. EUFUN_1(make_table, list)
  87. {
  88.   LispObject Fn_comparator_function(LispObject *);
  89.   LispObject Fn_hash_function(LispObject *);
  90.  
  91.   LispObject table;
  92.  
  93.   if (list==NULL)
  94.     list=nil;
  95.  
  96.   TBUG(fprintf(stderr,"Make table..\n"));
  97.   table=allocate_instance(stacktop,Table);
  98.   table_population(table)=allocate_integer(stacktop,0);
  99.   table_threshold(table)=allocate_integer(stacktop,MIN_TABLE_SIZE-TABLE_FILL_FACTOR);
  100.   table_fill(table)=nil;
  101.   
  102.   /* Check for fast table --- no delete, eq table, etc */
  103.   /* All Internal tables are "fast" */
  104.   if (list!=nil && CAR(list)!=EUCALL_0(Fn_comparator_function))
  105.     {
  106.       table_comparator(table)=CAR(list);
  107.       table_hash_fn(table)=EUCALL_0(Fn_hash_function);
  108.     }
  109.   else
  110.     {
  111.       table_comparator(table)=nil;
  112.       table_hash_fn(table)=nil;
  113.     }
  114.   return table;
  115. }
  116. EUFUN_CLOSE
  117.  
  118. EUFUN_2(Fn_table_ref,tab,key)
  119. {
  120.   int hash,index,limit;
  121.   LispObject vect,*ptr,*last_elt,tmp_hash;
  122.   int i;
  123.  
  124.   TBUG(fprintf(stderr,"In table-ref table: 0x%x key: 0x%x\n", table, key));
  125.   limit=vector_length(table_values(tab));
  126.   i=0;
  127.  
  128.   vect=table_values(tab);
  129.   if (!is_vector(vect))
  130.     return table_fill(tab);
  131.  
  132.   if (table_comparator(tab)==nil) /* Comparator ? */
  133.     {
  134.       hash=total_hash(key);
  135.       tab=ARG_0(stackbase);
  136.       key=ARG_1(stackbase);
  137.       vect=table_values(tab);
  138.       last_elt=&vref(vect,limit);
  139.   
  140.       ptr = &vref(vect,hash%limit);
  141.       
  142.       while (1)
  143.     {
  144.       if (ELTP(*ptr) && KEYOF(*ptr)==key) /** XXX: insert comparator here **/
  145.         return VALOF(*ptr);
  146.       
  147.       if (*ptr==nil)    /* Empty slot --- can't be any more */
  148.         return table_fill(tab);
  149.       
  150.       ptr++;
  151.       if (ptr==last_elt)
  152.         ptr=&vref(vect,0);
  153.     }
  154.     }
  155.   else
  156.     {    
  157.       tmp_hash=EUCALL_2(apply1,table_hash_fn(tab),key);
  158.       hash=intval(tmp_hash)%limit;
  159.       vect=table_values(ARG_0(stackbase));
  160.  
  161.       while (1)
  162.     {
  163.       LispObject tmp;
  164.  
  165.       STACK_TMP(vect);
  166.       if (hash==limit)
  167.         hash=0;
  168.  
  169.       if (vref(vect,hash)==nil)
  170.         return table_fill(ARG_0(stackbase));
  171.       
  172.       if (vref(vect,hash)!=lisptrue 
  173.           && (tmp=EUCALL_3(apply2,table_comparator(ARG_0(stackbase)),ARG_1(stackbase),KEYOF(vref(vect,hash))),
  174.           tmp==lisptrue))
  175.         {    
  176.           UNSTACK_TMP(vect);
  177.           return VALOF(vref(vect,hash));
  178.         }
  179.       UNSTACK_TMP(vect);
  180.       hash++;
  181.     }
  182.     }
  183.   CallError(stacktop,"Impossible to get here",nil,NONCONTINUABLE);
  184.   return nil;
  185. }
  186. EUFUN_CLOSE
  187.  
  188. EUFUN_3(Fn_table_ref_setter,tab,key,value)
  189. {
  190.   LispObject tmp_hash,vect;
  191.   int hash,limit;
  192.  
  193.   if (!is_vector(table_values(tab)))
  194.     {
  195.       vect=allocate_vector(stacktop,MIN_TABLE_SIZE);
  196.       tab=ARG_0(stackbase);
  197.       table_values(tab)=vect;
  198.     }
  199.   
  200.   limit=vector_length(table_values(tab));
  201.  
  202.   if (table_comparator(tab)==nil)
  203.     {
  204.       hash=total_hash(key)%limit;
  205.       tab=ARG_0(stackbase);
  206.       key=ARG_1(stackbase);
  207.       value=ARG_2(stackbase);
  208.       vect=table_values(tab);
  209.  
  210.       while (1)
  211.     {
  212.       if (!ELTP(vref(vect,hash)))
  213.         {            /* XXX: GC proof */
  214.           LispObject new;
  215.         
  216.           STACK_TMP(vect);
  217.           new=EUCALL_2(Fn_cons,key,value);
  218.           UNSTACK_TMP(vect);
  219.           vref(vect,hash)=new;
  220.       
  221.           new=allocate_integer(stacktop,intval(table_population(ARG_0(stackbase)))+1);
  222.           table_population(ARG_0(stackbase))=new;
  223.  
  224.           if (intval(table_population(ARG_0(stackbase)))==intval(table_threshold(ARG_0(stackbase))))
  225.         table_rehash(stacktop,ARG_0(stackbase));
  226.  
  227.           return table_fill(ARG_0(stackbase));
  228.         }
  229.       
  230.       if (KEYOF(vref(vect,hash))==key) /* XXX: Insert comparator here */
  231.         {
  232.           LispObject old;
  233.       
  234.           old=VALOF(vref(vect,hash));
  235.           VALOF(vref(vect,hash))=value;
  236.  
  237.           return old;
  238.         }    
  239.       hash++;
  240.       if (hash==limit)
  241.         hash=0;    
  242.     }
  243.     }
  244.   else
  245.     {
  246.       tmp_hash=EUCALL_2(apply1,table_hash_fn(tab),key);
  247.       hash=intval(tmp_hash)%limit;
  248.       tab=ARG_0(stackbase);
  249.       vect=table_values(tab);
  250.  
  251.       while (1)
  252.     {    
  253.       LispObject tmp;
  254.  
  255.       if (!ELTP(vref(vect,hash)))
  256.         {            /* XXX: GC proof */
  257.           LispObject new;
  258.         
  259.           STACK_TMP(vect);
  260.           new=EUCALL_2(Fn_cons,key,value);
  261.           UNSTACK_TMP(vect);
  262.           vref(vect,hash)=new;
  263.           
  264.           new=allocate_integer(stacktop,intval(table_population(ARG_0(stackbase)))+1);
  265.           tab=ARG_0(stackbase);
  266.           table_population(tab)=new;
  267.  
  268.           if (intval(table_population(ARG_0(stackbase)))==intval(table_threshold(ARG_0(stackbase))))
  269.         table_rehash(stacktop,ARG_0(stackbase));
  270.  
  271.           return table_fill(ARG_0(stackbase));
  272.         }
  273.  
  274.       STACK_TMP(vect);
  275.       tmp=EUCALL_3(apply2,table_comparator(ARG_0(stackbase)),KEYOF(vref(vect,hash)),ARG_1(stackbase));
  276.       if (tmp!=nil)
  277.         {
  278.         LispObject old;
  279.  
  280.         UNSTACK_TMP(vect);
  281.         old=VALOF(vref(vect,hash));
  282.         VALOF(vref(vect,hash))=ARG_2(stackbase);
  283.  
  284.         return old;
  285.           }    
  286.       UNSTACK_TMP(vect);
  287.       hash++;
  288.       if (hash==limit)
  289.         hash=0;    
  290.     }
  291.     }
  292. }
  293. EUFUN_CLOSE
  294.  
  295. EUFUN_2(Fn_table_delete,tab,key)
  296. {
  297.  
  298.   
  299.   return nil;
  300. }
  301. EUFUN_CLOSE
  302.  
  303. static void table_rehash(LispObject *stacktop, LispObject tab)
  304. {
  305.   LispObject *stackbase=stacktop;
  306.   LispObject oldvect, newvect,hash_fn;
  307.   int newsize;
  308.   int hashval;
  309.   int i;
  310.   
  311.   stacktop++;
  312.   newsize=vector_length(table_values(tab))*2;
  313.   STACK_TMP(tab);
  314.   table_threshold(tab)=allocate_integer(stacktop,intval(table_threshold(tab))*2);
  315.   UNSTACK_TMP(tab) ; STACK_TMP(tab);
  316.   newvect=allocate_vector(stacktop,newsize);
  317.   UNSTACK_TMP(tab);
  318.   oldvect=table_values(tab);
  319.  
  320.   if (table_comparator(tab)==nil)
  321.     hash_fn=NULL;
  322.   else
  323.     hash_fn=table_hash_fn(tab);
  324.   
  325.   ARG_0(stackbase)=hash_fn;
  326.   STACK_TMP(tab);
  327.   for (i=0 ; i<vector_length(oldvect) ; i++)
  328.     {
  329.       if (ELTP(vref(oldvect,i)))
  330.     {
  331.       LispObject new;
  332.       
  333.       STACK_TMP(oldvect);
  334.       STACK_TMP(newvect);
  335.  
  336.       if (hash_fn)
  337.         hashval=intval(EUCALL_2(apply1,ARG_0(stackbase),KEYOF(vref(oldvect,i))));
  338.       else
  339.         hashval=total_hash(KEYOF(vref(oldvect,i)));
  340.       UNSTACK_TMP(newvect);
  341.       UNSTACK_TMP(oldvect);
  342.       
  343.       new=vref(oldvect,i);
  344.  
  345.       while (vref(newvect,hashval%newsize)!=nil)
  346.         hashval++;
  347.       
  348.       vref(newvect,hashval%newsize) = new;
  349.     }
  350.     }
  351.   UNSTACK_TMP(tab);
  352.   table_values(tab)=newvect;
  353.   
  354.   
  355. }
  356.  
  357. /* Other minor functions */
  358. /* NB: map-table and copy-table implemented by table.em */
  359. /* This would be *so* nice with generators/iterators */
  360. EUFUN_1(Fn_table_parameters,table)
  361. {
  362.   LispObject plist;
  363.   int tlen,i;
  364.   
  365.   if (!is_vector(table_values(table)))
  366.     return nil;
  367.  
  368.   tlen=vector_length(table_values(table));
  369.   plist=nil;
  370.   for (i=0 ; i<tlen ; i++)
  371.     {
  372.       LispObject elt;
  373.  
  374.       elt=vref(table_values(ARG_0(stackbase)),i);
  375.       
  376.       if (elt!=nil)
  377.     plist=EUCALL_2(Fn_cons,elt,plist);
  378.     }
  379.   return plist;
  380. }
  381. EUFUN_CLOSE
  382.  
  383. EUFUN_1(Fn_table_values,table)
  384. {
  385.   return table_values(table);
  386. }
  387. EUFUN_CLOSE
  388.  
  389. static LispObject Cb_std_tab_functions;
  390.  
  391. EUFUN_0(Fn_hash_function)
  392. {
  393.   return CAR(Cb_std_tab_functions);
  394. }
  395. EUFUN_CLOSE
  396.  
  397. EUFUN_0(Fn_comparator_function)
  398. {
  399.   return CDR(Cb_std_tab_functions);
  400. }
  401. EUFUN_CLOSE
  402.  
  403. EUFUN_2(Fn_set_std_tab_functions,hash,comp)
  404. {
  405.   CAR(Cb_std_tab_functions)=hash;
  406.   CDR(Cb_std_tab_functions)=comp;
  407.   return lisptrue;
  408. }
  409. EUFUN_CLOSE
  410.  
  411. EUFUN_1(Fn_table_comparator,tab)
  412. {
  413.   if (table_comparator(tab)==nil)
  414.     return CDR(Cb_std_tab_functions);
  415.   else
  416.     return table_comparator(tab);
  417. }
  418. EUFUN_CLOSE
  419.  
  420. EUFUN_1(Fn_table_hash_function,tab)
  421. {
  422.   if (table_hash_fn(tab)==nil)
  423.     return CAR(Cb_std_tab_functions);
  424.   else
  425.     return table_hash_fn(tab);
  426.  
  427. }
  428. EUFUN_CLOSE
  429. int general_hash(LispObject *stacktop,LispObject x)
  430. {
  431.  
  432.   x=EUCALL_2(apply1,CAR(Cb_std_tab_functions),x);
  433.   
  434.   return intval(x);
  435. }
  436.  
  437. /* Initialisation */
  438.  
  439. #define TABLES_ENTRIES 7
  440. MODULE Module_tables;
  441. LispObject Module_tables_values[TABLES_ENTRIES];
  442.  
  443. void initialise_tables(LispObject *stacktop)
  444. {
  445.   LispObject fun, upd;
  446.  
  447.   Cb_std_tab_functions=EUCALL_2(Fn_cons,nil,nil);
  448.   add_root(&Cb_std_tab_functions);
  449.   open_module(stacktop,    
  450.           &Module_tables,
  451.           Module_tables_values,
  452.           "tables",
  453.           TABLES_ENTRIES);
  454.  
  455.   (void) make_module_function(stacktop,"symbol-hash",Fn_symbol_hash,1);
  456.   (void) make_module_function(stacktop,"make-table",make_table,-1);
  457.   (void) make_module_function(stacktop,"table-parameters",Fn_table_parameters,1);
  458.   fun = make_module_function(stacktop,"sys-table-ref",Fn_table_ref,2);
  459.   STACK_TMP(fun);
  460.   upd = make_unexported_module_function(stacktop,"sys-table-ref-setter", Fn_table_ref_setter, 3);
  461.   UNSTACK_TMP(fun);
  462.   set_anon_associate(stacktop,fun, upd);
  463.   (void) make_module_function(stacktop,"standard-hash-function",Fn_hash_function,0);
  464.   (void) make_module_function(stacktop,"set-standard-tab-functions",Fn_set_std_tab_functions,2);
  465.  
  466.   close_module();
  467. }
  468.  
  469.